System Booster/System Booster.iso/Archives/ARexxTools/ScionRexx.lha/PrintPedigree.rexx

OS/2 REXX Batch file | 1995-10-31 | 23.0 KB | 816 lines

/****************************************************************************
 *                                                                          *
 * $VER: PrintPedigree 2.05 (30 Oct 1995)
 *                                                                          *
 *                      Written by Freddy Ariës                             *
 * Address: Lindeboomweg 7, NL-7135 KE Harreveld, The Netherlands.          *
 *                                                                          *
 * Output options:                                                          *
 *  1. Forefathers (male ancestor line only)       [Dutch: stamreeks]       *
 *  2. Pedigree Chart; no siblings                 [Dutch: kwartierstaat]   *
 *  3. Pedigree Chart; only siblings of proband  (= of youngest generation) *
 *  4. Pedigree Chart; all siblings                                         *
 *                                                                          *
 * This script uses (by default) the rexxreqtools.library (which requires   *
 * a version of reqtools larger than 2.0 and rexxsyslib.library)            *
 * If you do not have these, run SetDefaults.rexx to change the settings.   *
 *                                                                          *
 * As of v2 of this script, and Scion V4, the current person on Scion's     *
 * Personal Window will be used to determine where the search starts.       *
 * Scion 3.13 can still be used, though, in which case the user will be     *
 * asked at which IRN he wants to start.                                    *
 *                                                                          *
 * So why this PrintPedigree script when Scion already has a print option   *
 * for pedigree charts? Well, the reason is simple: the format of the       *
 * pedigree charts generated by Scion does not conform to the guidelines    *
 * of the Dutch CBG (Central Bureau for Genealogy) and NGV (Nederlandse     *
 * Genealogische Vereniging; Dutch Genealogical Society). So I created my   *
 * own PrintPedigree script, that *does* follow their guidelines.           *
 *                                                                          *
 * DONE:                                                                    *
 *  - Now uses preference file for default settings                         *
 *  - count the number of lines output and give a formfeed after a          *
 *    certain number (ie. skip page breaks)                                 *
 *                                                                          *
 * TO DO (low priority, unless someone really wants this):                  *
 *  - add a menu option for the maximum number of generations to print      *
 *  - allow user to specify if he wants burial data, occupation, comments,  *
 *    references fields, etc. printed                                       *
 *  - option: include empty fields                                          *
 *  - find a good way to handle sex-fields with value '?' (see below)       *
 *  - Suggestions, comments, bugreports, donations, etc. are appreciated.   *
 *                                                                          *
 * Known Bugs/Problems:                                                     *
 *  - This script is dog slow for large databases (ie. more than, say, 10   *
 *    generations), even on Amigas with a Turboboard!                       *
 *  - Incorrect assumptions may be made (with regard to father/mother) when *
 *    there are persons in the database whose sex-field has value '?'       *
 *                                                                          *
 ****************************************************************************/

options results
arg prtin outname noirn mgen outval

versionstr = "2.05"

/* Don't change the settings here! Run SetDefaults.rexx instead! */
usereq = 1; outp = 1; useirn = 1
prtdev = stdout; prtopt = 0; scrdev = stdout
plwidth = 78; pgsize = 0
PSCR = 'SCIONGEN'

scrname = "CON:0//639//Scion Output/AUTO/SCREEN"
prtrev = 0;    /* prtrev = 0 means youngest (first) generation = I */
        /* prtrev = 1 means oldest (last) generation = I */
DbtGen = 10;
  /* Suggested value for 68000: 10, with Turbo-boards: 12
   * From this generation onwards, every additional generation needs a confirm
   * Note: 10 generations means (up to) 1024 persons,
   * 12 generations means (up to) 4096 persons !!!
   */
pgline = 1
NL = '0A'x

signal on IOERR

/* parse command line options, to allow calling the script automatically,
 * eg. from a function key
 */

do while prtin = '?'
  Tell("NUMOPT/A/N,OUTFILE/A,NOIRN/S,MAXGEN/N,QUIET/S,NOREQ/S: ")
  pull prtin outname noirn mgen outval
end

/* read preferences file */

if open(pfile, 'ENV:Scion/ScionRexx.prefs', 'r') then do
  do while ~eof(pfile)
    inln = readln(pfile)
    if inln ~= "" then do
      wstr = upper(word(inln, 1))
      if wstr = "USEREQ" then
        usereq = 1
      else if wstr = "NOUSEREQ" then
        usereq = 0
      else if wstr = "PUBSCREEN" then
        pscr = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
      else if wstr = "LINEWIDTH" then do
        wstr = word(inln, 2)
        if datatype(wstr, 'w') then plwidth = wstr
      end
      else if wstr = "PAGESIZE" then do
        wstr = word(inln, 2)
        if datatype(wstr, 'w') then pgsize = wstr
      end
    end
  end
  close(pfile)
end

if pscr = "" | (pscr ~= "WORKBENCH" & ~show('p', pscr)) then
  pscr = "SCIONGEN"
scrname = scrname||pscr

/* Command line options get priority over global settings */
ParseArguments()

if ~show('l','rexxarplib.library') then do
  if exists('libs:rexxarplib.library') then
    call addlib('rexxarplib.library',0,-30,0)
end

screentofront(pscr)

if usereq & ~show('l','rexxreqtools.library') then do
  if exists('libs:rexxreqtools.library') then
    call addlib('rexxreqtools.library',0,-30,0)
  else do
    usereq = 0; outp = 1
    Tell("Unable to open rexxreqtools.library - using text output")
  end
end

/* Originally stolen from Peter Billing - thanks Peter ;-) */
if ~show('P','SCIONGEN') then do
  EndString('I am sorry to say that the SCION Genealogist' || NL ||,
    'database is not available. Please start the' || NL ||,
    'SCION program BEFORE using this script!')
end

myport = "SCIONGEN"
address value myport
GETDBNAME
dbname = upper(RESULT)
GETPROGVERSION
progvers = RESULT

if progvers >= 4 then do
  GETCURRENTIRN
  irn = RESULT
end

if outp & ~usereq then do
  if pscr ~= "WORKBENCH" then do
    scrdev = 'SCNPEDSCR'
    if ~open(scrdev, scrname, 'w') then scrdev = stdout
  end
  Tell("*** PrintPedigree version "||versionstr||" ***")
  Tell("***       by Freddy Ariës      ***")
  Tell("Current database: "||dbname||NL)
end
if prtopt = 0 then do
  /* No use in asking for input if we're not allowed to output anything */
  if usereq then do
    prtopt = rtezrequest('Current Scion database: '||dbname||NL||,
      NL||'Please make your choice: '||,
      NL||'1. Forefathers (male ancestor line only)'||,
      NL||'2. Pedigree Chart; no siblings'||,
      NL||'3. Pedigree Chart; only siblings of proband'||,
      NL||'4. Pedigree Chart; all siblings'||,
      '',' _1 | _2 | _3 | _4 |E_xit','PrintPedigree v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
    if prtopt = 0 then EXIT

    if progvers < 4 then do
      irn = rtgetlong(,'Enter the IRN of the person whose'||,
            NL||'ancestors you want to print: '||,
            NL,'Input Request:','_Continue','rt_pubscrname = '||PSCR)
      if irn = '' then EndString("No IRN - aborted.")
      irn = abs(irn)
    end

    useirn = rtezrequest('Do you want to output the IRNs'||,
              NL||'(the record numbers) as well?'||,
              '',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
  end
  else do
    Tell("1. Forefathers (male ancestor line only)")
    Tell("2. Pedigree Chart; no siblings")
    Tell("3. Pedigree Chart; only siblings of proband")
    Tell("4. Pedigree Chart; all siblings")
    TellNN("Your choice: ")
    prtopt = readln(scrdev)
    prtopt = CheckAnswer(word(prtopt,1))

    if progvers < 4 then do
      TellNN("Enter the IRN of the person whose ancestors you want to print: ")
      irn = readln(scrdev)
      irn = word(irn, 1)
    end

    TellNN("Do you want to output the IRN (numbers) as well (y/n)? ")
    instr = readln(scrdev)
    instr = upper(left(instr, 1))
    Tell("")
    if instr = "Y" then useirn = 1
    else useirn = 0
  end
end

if progvers < 4 & ~DATATYPE(irn, 'w') then
  EndString("ERROR: Not a valid IRN: "||irn)

EXISTPERSON irn
if RESULT ~= 'YES' then
  EndString("No person with IRN "||irn||" in the current database.")

if outp then do
  pname = GetNameStr(irn, 0)
  if usereq then do
    valcont = rtezrequest('The selected person is: '||NL||pname||'.'||,
      NL||'Continue?','_Continue| _Abort','PrintPedigree Request:','rt_pubscrname = '||PSCR)
    if valcont = 0 then EndString("Aborted.")
  end
  else do
    TellNN("Current person is "||pname||". Continue? (y/n) ")
    valcont = readln(scrdev)
    valcont = upper(left(valcont, 1))
    if valcont ~= 'Y' then EndString("Ok.")
  end
end

if outp & outname = "" then do
  if usereq then do
    odev = rtezrequest('Current Scion database: '||dbname||,
      NL||'Where should the output be sent to?'||,
      NL,' _File |_Printer|_Screen|_Nowhere','PrintPedigree v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
    select
      when odev = 1 then do
        /* We need a file requester for further data */
        dblen = length(dbname)
        if dblen>6 & right(dbname, 6)=".SCION" then
          dbname=left(dbname, dblen - 6)
        outname = rtfilerequest(,dbname||'.PED','Output filename',,'rtfi_buffer = true   rt_pubscrname = '||PSCR||'   rtfi_initialpath = RAM:',)
        if outname = '' then
          outname = dbname||'.PED'
      end
      when odev = 2 then
        outname = 'PRT:'
      when odev = 3 then
        outname = 'STDOUT'
      otherwise EndString("No output - aborted.")
        /* You selected 'Nowhere' */
    end
  end
  else do
    Tell("Enter output file (filename with complete path, or PRT: for printer,")
    TellNN("or STDOUT for screen): ")
    outname = readln(scrdev)
    outname = strip(outname, 'b', ' "')
    if outname = "" then outname = 'STDOUT'
  end
end

/* Anyone know a better way to translate numbers into Roman? */
GenerationS.1 = "I II III IV V VI VII VIII IX X XI XII XIII XIV XV XVI XVII XVIII XIX XX"
GenerationS.2 = "XXI XXII XXIII XXIV XXV XXVI XXVII XXVIII XXIX XXX XXXI XXXII XXXIII XXXIV XXXV XXXVI XXXVII XXXVIII IXL XL"

/* Printer Codes (some of which are currently unused): */
ESC = '1B'x
prtinit = ESC||"#1";     /* ESC#1 initialize      */
prtundon = ESC||"[4m";   /* ESC[4m underline on   */
prtundoff = ESC||"[24m"; /* ESC[24m underline off */
prtdson = ESC||"[1m";    /* ESC[1m boldface on    */
prtdsoff = ESC||"[22m";  /* ESC[22m boldface off  */
prtnlqon = ESC||"[2"||'22'x||"z";  /* ESC[2"z NLQ on  */
prtnlqoff = ESC||"[1"||'22'x||"z"; /* ESC[1"z NLQ off */

if ~usereq then
  Tell("Building ancestor table...")

currgen = 1; numpers = 1
GENTREE.1 = irn

/* Build the ancestor table */
do until ~foundone
  foundone = 0
  currgen = currgen + 1
  numpers = 2 * numpers
  /* = 2 ** (currgen - 1) */
  if currgen <= MaxGens then
  do
    if currgen > DbtGen then
    do
      if usereq then
      do
        docont = rtezrequest('Also parse generation '||currgen||' ?'||,
              NL||'(this may take *very* long!)'||,
              '',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
      end
      else
      do
        Tell("Also parse generation '||currgen||' ?' (this may take *very* long!)")
        inp = readln(scrdev)
        inp = upper(left(inp, 1))
        Tell("")
        if inp = "Y" then docont = 1
        else docont = 0
      end
    end
    else docont = 1

    if docont then
    do
      if prtopt = 1 then
        endnum = numpers+1
        /* no use to build the entire table, if we need only this little */
      else
        endnum = 2*numpers-1
      /*
       * TO DO: at the moment, all the numbers are parsed, even if there
       *  is only one family group with ancestors in this generation
       *  This means that thousands of fields may be checked, to find
       *  two persons. This also makes the program dog slow!
       *  I must find a better method to do this. Suggestions welcome...
       */
      do ct = numpers to endnum by 2
        ct1 = ct % 2
        irn = GENTREE.ct1
        ct1 = ct + 1
        GENTREE.ct = 0
        GENTREE.ct1 = 0
        if irn ~= 0 then do
          GETPARENTS irn
          fgrn = RESULT
          EXISTFAMILY fgrn
          if RESULT = 'YES' then do
            foundone = 1
            GetParentsIRN(fgrn, ct, ct1)
          end
        end
      end
    end
  end
  else do
    if usereq then
      rtezrequest('Maximum number of'||NL||'generations reached.'||NL||,
    NL||'Output truncated','_Continue','PrintPedigree Message:','rt_pubscrname = '||PSCR)
    else
     Tell("Maximum number of generations reached. Output may be truncated.")
  end
end
numgens = currgen - 1

/* Now print all the ancestors */
if ~usereq then
  Tell("Printing data...")

OpenPrinter()

if prtopt = 1 then do
  /* Forefathers; print only male ancestors */
  fill = 7
  np = numpers%2
  if prtrev then
    currgen = currgen - 1
  else
    currgen = 1
  do while np > 1
    g1 = GetGenStr(currgen, fill)
    ct1 = np + 1
    ct2 = np % 2
    /* get the husband's data */
    g1 = g1||GetPersonStr(GENTREE.np)

    GETPARENTS GENTREE.ct2
    mf1 = RESULT
    EXISTFAMILY mf1
    if RESULT = 'YES' then
      m1 = GetMarriageStr(mf1)
    else
      m1 = ""

    if m1 ~= "" then
      m1 = g1||", m: "||m1
    else m1 = g1
    g1 = copies(' ',fill)
    PrintLines(m1, fill)
    /* get the wife's data */
    m1 = g1||GetPersonStr(GENTREE.ct1)
    PrintLines(m1, fill)
    PrintLF()
    if prtrev then
      currgen = currgen - 1
    else
      currgen = currgen + 1
    np = np % 2
  end
  g1 = GetGenStr(currgen, fill)||GetPersonStr(GENTREE.np)
  g1 = g1||GetMarriages(GENTREE.np)
  PrintLines(g1, fill)
  PrintLF()
end
else do
  /* print all */
  if prtrev then
    currgen = currgen - 1
  else
    currgen = 1
  fill = 6

  g1 = center("Generation: "||GetGenStr(currgen, fill), plwidth-1)
  PrintLines(g1, fill)
  g1 = "1.    "||GetPersonStr(GENTREE.1)
  g1 = g1||GetMarriages(GENTREE.1)
  PrintLines(g1, fill)
  if prtopt > 2 then
    PrintSiblings(GENTREE.1, 1)
  PrintLF()

  np = 2
  if prtrev then
    currgen = currgen - 1
  else
    currgen = currgen + 1
  do while np < numpers
    g1 = center("Generation: "||GetGenStr(currgen, fill), plwidth)
    PrintLines(g1, fill)
    endnum = 2*np-1
    do ct = np to endnum by 2
      ct1 = ct + 1
      ct2 = ct % 2
      /* print the principal data */
      if GENTREE.ct ~= 0 then do
        g1 = left(ct||".    ",fill)||GetPersonStr(GENTREE.ct)

    GETPARENTS GENTREE.ct2
    mf1 = RESULT
    EXISTFAMILY mf1
    if RESULT = 'YES' then
      m1 = GetMarriageStr(mf1)
    else
      m1 = ""

        if m1 ~= "" then
          m1 = g1||", m: "||m1
        else m1 = g1
        g1 = copies(' ',fill)
        PrintLines(m1, fill)
        if prtopt = 4 then
          PrintSiblings(GENTREE.ct, ct)
      end
      /* print the spouse data */
      if GENTREE.ct1 ~= 0 then do
        m1 = left(ct1||".    ",fill)||GetPersonStr(GENTREE.ct1)
        PrintLines(m1, fill)
        if prtopt = 4 then
          PrintSiblings(GENTREE.ct1, ct1)
      end
    end
    PrintLF()
    if prtrev then
      currgen = currgen - 1
    else
      currgen = currgen + 1
    np = np * 2
  end
end
if numgens = 1 then
  PrintLines("No ancestors are recorded for this person.", 0)

writech(prtdev, prtnlqoff); /* ESC[1"z NLQ off */
EndString("Done.")

EXIT

/* Parse command line arguments and set the appropriate global variables */
ParseArguments:
if noirn = "NOIRN" then useirn = 0
else if noirn = "QUIET" || noirn = "NOREQ" then do
  outval = noirn
  noirn = ""
end
else do
  outval = mgen
  mgen = noirn
  noirn = ""
end
if mgen = "QUIET" || mgen = "NOREQ" then do
  outval = mgen
  mgen = ""
end

MaxGens = 20
/* due to the Roman numbers, we can't handle more than 40 */
/* but due to speed limitations, I don't advise using more than 20 */
if mgen ~= "" then do
  if DATATYPE(mgen, 'w') & mgen > 0 & mgen < MaxGens then
    MaxGens = mgen
end

if outval = "QUIET" then do
  usereq = 0
  outp = 0
end
else if outval = "NOREQ" then
  usereq = 0

/* if outname = "" then outname = 'STDOUT' */

if prtin = "" then do
  prtopt = 0
  if ~outp then EndString("Requires argument is missing.")
    /* actually, with outp = 0, all it does is EXIT */
end
else do
  prtopt = CheckAnswer(prtin)
  /* Note that it was important to establish outp before calling these */
end

return 0

OpenPrinter:
/* Open the printer device and print out a nice header */
if outname = 'STDOUT' then
  prtdev = scrdev
else do
  prtdev = "PRINTER"
  if ~open(prtdev, outname, 'w') then
    EndString("ERROR: Failed to open output file!")
end
writech(prtdev, prtinit||prtnlqon)
if prtopt = 1 then
  prtstr = "FOREFATHERS (Male ancestor line only)"
else if prtopt = 2 then
  prtstr = "PEDIGREE CHART; No siblings"
else if prtopt = 3 then
  prtstr = "PEDIGREE CHART; Only siblings of proband"
else
  prtstr = "PEDIGREE CHART; All siblings"
prtstr = prtundon||prtdson||prtstr||prtdsoff||prtundoff
DoWrite(prtdev, prtstr)
prtstr = prtdson||"Report printed on: "||date()||prtdsoff
DoWrite(prtdev, prtstr)
prtstr = copies('=', plwidth)
DoWrite(prtdev, prtstr)
return 0

PrintLines: PROCEDURE EXPOSE prtdev plwidth prtopt pgline pgsize
parse arg ostr, fill
/* TO DO:
 * if there are control strings within ostr (like prtdson or prtdsoff)
 * don't include them in the length count
 */
do while ostr ~= ""
  nnl = plwidth+1
  if length(ostr) > plwidth then do
    do until pc = ' ' | nnl = 1
      pc = substr(ostr, nnl, 1)
      nnl = nnl - 1
    end
    if nnl = 1 then do
      prtstr = left(ostr, plwidth)
      ostr = delstr(ostr, 1, nnl)
    end
    else do
      prtstr = left(ostr, nnl)
      ostr = delstr(ostr, 1, nnl+1)
    end
  end
  else do
    prtstr = ostr
    ostr = ""
  end
  DoWrite(prtdev, prtstr)
  if ostr ~= "" then
    ostr = copies(' ',fill)||ostr
end
return 0

PrintLF:
DoWrite(prtdev, "")
return 0

PrintSiblings: PROCEDURE EXPOSE prtdev plwidth prtopt useirn pgline pgsize
parse arg inum, prenum
GETPARENTS inum
famfgrn = RESULT
EXISTFAMILY famfgrn
if RESULT ~= 'YES' then return 0; /* no parents, then no siblings */
ix = 0; chnum = 0
do until ischld ~= 'YES'
  GETCHILD famfgrn ix
  prsn = RESULT
  EXISTPERSON prsn
  ischld = RESULT
  if ischld = 'YES' then do
    chnum = chnum + 1
    /* skip a number for person <inum> to indicate where he fits in */
    if prsn ~= inum then do
      ostr = copies(' ',8)||prenum||D2C(chnum+96)". "||GetPersonStr(prsn)
      PrintLines(ostr, 11)
      if chnum = 26 then return 0; /* 'z': can't handle more than 26 children */
    end
  end
  ix = ix + 1
end
return 0

GetGenStr: PROCEDURE EXPOSE prtopt GenerationS.
parse arg gnum, fill
if gnum <= 20 then
  gstr = word(GenerationS.1, gnum)
else if gnum <= 40 then
  gstr = word(GenerationS.2, gnum)
else
  return "["||gnum||"]"
if prtopt = 1 then gstr = left(gstr||".     ",fill)
return gstr

GetPersonStr: PROCEDURE EXPOSE useirn
parse arg irn
if irn ~= 0 then do
  nstr = GetNameStr(irn)
  nstr = nstr||GetBirthStr(irn)
  nstr = nstr||GetDeathStr(irn)
end
else
  nstr = "UNKNOWN"
return nstr

GetNameStr: PROCEDURE EXPOSE useirn
parse arg gnum
/* prtdson = '1B'x||"[1m";    * ESC[1m boldface on    */
/* prtdsoff = '1B'x||"[22m";  * ESC[22m boldface off  */
GETFIRSTNAME gnum
name = RESULT
if name ~= "" then name = name||" "
GETLASTNAME gnum
lname = RESULT
if lname = "" then lname = "UNKNOWN"
name = name||lname
/* another option: name = name||prtdson||lname||prtdsoff
 * Problem: see PrintLines
 */
if useirn then name = name||" ["gnum"]"
return name

GetBirthStr: PROCEDURE
parse arg gnum
GETBIRTHPLACE gnum
bstr = RESULT
GETBIRTHDATE gnum
bdat = RESULT
if bdat ~= "" & bstr ~= "" then bstr = bstr||" "
bstr = bstr||bdat
if bstr ~= "" then bstr = ", b: "||bstr
return bstr

GetDeathStr: PROCEDURE
parse arg gnum
GETDEATHPLACE gnum
dstr = RESULT
GETDEATHDATE gnum
ddat = RESULT
if ddat ~= "" & dstr ~= "" then dstr = dstr||" "
dstr = dstr||ddat
if dstr ~= "" then dstr = ", d: "||dstr
return dstr

GetMarriages: PROCEDURE EXPOSE useirn
parse arg irn
mstr = ""
GETMARRIAGE irn 0
mf = RESULT
EXISTFAMILY mf
if RESULT = 'YES' then do
  mtrue = 1
  GETMARRIAGE irn 1
  m2 = RESULT
  EXISTFAMILY m2
  if RESULT = 'YES' then mset = 1
  else mset = 0
end
else
  mtrue = 0
mnum = 0
do while mtrue
  m1 = GetMarriageStr(mf)
  if m1 ~= "" then m1  = m1||' '
  ptn = GetPartnerIRN(mf, irn)
  m1 = m1||GetPersonStr(ptn)

  mnum = mnum + 1
  if mset then mstr = mstr||", m("||mnum||"): "||m1
  else mstr = mstr||", m: "||m1

  GETMARRIAGE irn mnum
  mf = RESULT
  EXISTFAMILY mf
  if RESULT ~= 'YES' then mtrue = 0
end
return mstr

GetMarriageStr: PROCEDURE
parse arg mf
GETMARRYPLACE mf
mstr = RESULT
GETMARRYDATE mf
mdat = RESULT
if mdat ~= "" & mstr ~= "" then mstr = mstr||" "
mstr = mstr||mdat
return mstr

GetParentsIRN: PROCEDURE EXPOSE GENTREE.
parse arg fnum, ct, ct1
fath = 0; moth = 0
GETSPOUSE fnum
sps = RESULT
EXISTPERSON sps
if RESULT = 'YES' then do
  GETSEX sps
  if RESULT = 'M' then
    fath = sps
  else moth = sps
end
GETPRINCIPAL fnum
prn = RESULT
/* If there are two mothers, or two fathers, then name the principal
 * as 'father' and the spouse as 'mother'
 */
EXISTPERSON prn
if RESULT = 'YES' then do
  GETSEX prn
  if RESULT = 'M' then do
    if fath ~= 0 then
      moth = sps
    fath = prn
  end
  else if moth ~= 0 then
    fath = prn
  else
    moth = prn
end
GENTREE.ct = fath
GENTREE.ct1 = moth
return 0

GetPartnerIRN: PROCEDURE
parse arg fnum, inum
GETPRINCIPAL fnum
prn = RESULT
GETSPOUSE fnum
sps = RESULT
if inum = prn then pnum = sps
else if inum = sps then pnum = prn
else pnum = 0
return pnum

CheckAnswer: PROCEDURE EXPOSE outp prtdev usereq scrdev
parse arg str
str = left(str, 1)
if ~DATATYPE(str, 'w') | (str < 1 | str > 4) then
  EndString("Invalid option - aborted.")
return  str

/*
 * output at most #pgsize lines per page to the print device
 * if pgsize = 0, this feature is turned off (unlimited #lines per page)
 */
DoWrite: PROCEDURE EXPOSE pgline pgsize
parse arg prtdev, ostr
if pgsize ~= 0 & pgline > pgsize then do
  writech(prtdev, '0C'x); /* CTRL-L; next page */
  pgline = 0
end
writeln(prtdev, ostr)
pgline = pgline + 1
return 0

Tell: PROCEDURE EXPOSE outp scrdev
parse arg str
if outp then
  writeln(scrdev, str)
return 0

TellNN: PROCEDURE EXPOSE outp scrdev
/* Tell, No Newline */
parse arg str
if outp then
  writech(scrdev, str)
return 0

EndString: PROCEDURE EXPOSE outp prtdev usereq scrdev pscr
parse arg str
/* If you turned off stdout, no error messages will be shown! */
if usereq then
  rtezrequest(str,'E_xit','PrintPedigree Message:','rt_pubscrname = '||PSCR)
else do
  Tell(str || '0A'x)
end
if outp & ~usereq & (scrdev ~= stdout) then do
  Tell("Press <return> to exit.")
  readln(scrdev)
  close(scrdev)
end
close(prtdev)
EXIT

/* Let's make sure you get a nice message when you turn off the printer :-) */

IOERR:
  bline = SIGL
  say "I/O error #"||RC||" detected in line "||bline||":"
  say sourceline(bline)
  EXIT